home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / OREF.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  19.6 KB  |  690 lines
  1. /*
  2.  * File: oref.r
  3.  *  Contents: bang, random, sect, subsc
  4.  */
  5.  
  6. "!x - generate successive values from object x."
  7.  
  8. operator{*} ! bang(underef x -> dx)
  9.    declare {
  10.       register C_integer i, j;
  11.       tended union block *ep;
  12.       struct hgstate state;
  13.       char ch;
  14.       }
  15.  
  16.    if is:variable(x) && is:string(dx) then {
  17.       abstract {
  18.          return new tvsubs(type(x))
  19.          }
  20.       inline {
  21.          /*
  22.           * A nonconverted string from a variable is being banged.
  23.           *  Loop through the string supending one character substring
  24.           *  trapped variables.
  25.           */
  26.          for (i = 1; i <= StrLen(dx); i++) {
  27.             suspend substr(&x, i, (word)1);
  28.             deref(&x, &dx);
  29.             if (!is:string(dx)) 
  30.                runerr(103, dx);
  31.             }
  32.          }
  33.       }
  34.    else if cnv:tmp_string(dx) then {
  35.       abstract {
  36.          return string
  37.          }
  38.       inline {
  39.          /*
  40.           * A (converted or non-variable) string is being banged.
  41.           * Loop through the string suspending simple one character
  42.           *  substrings.
  43.           */
  44.          for (i = 1; i <= StrLen(dx); i++) {
  45.             ch = *(StrLoc(dx) + i - 1);
  46.             suspend string(1, &allchars[FromAscii(ch) & 0xFF]);
  47.             }
  48.          }
  49.       }
  50.    else type_case dx of {
  51.  
  52.       list: {
  53.          abstract {
  54.             return type(dx).lst_elem
  55.         }
  56.          inline {
  57.             /*
  58.              * x is a list.  Chain through each list element block and for
  59.              * each one, suspend with a variable pointing to each
  60.              * element contained in the block.
  61.              */
  62.             for (ep = BlkLoc(dx)->list.listhead; ep != NULL;
  63.                  ep = ep->lelem.listnext){
  64.                for (i = 0; i < ep->lelem.nused; i++) {
  65.                   j = ep->lelem.first + i;
  66.                   if (j >= ep->lelem.nslots)
  67.                      j -= ep->lelem.nslots;
  68.                   suspend struct_var(&ep->lelem.lslots[j], ep);
  69.                   }
  70.                }
  71.             }
  72.          }
  73.  
  74.       file: {
  75.          abstract {
  76.             return string
  77.            }
  78.          body {
  79.             FILE *fd;
  80.             char sbuf[MaxCvtLen];
  81.             register char *sp;
  82.             register C_integer slen, rlen;
  83.             word status;
  84.  
  85.             /*
  86.              * x is a file.  Read the next line into the string space
  87.              *    and suspend the newly allocated string.
  88.              */
  89.             fd = BlkLoc(dx)->file.fd;
  90.    
  91.             status = BlkLoc(dx)->file.status;
  92.             if ((status & Fs_Read) == 0) 
  93.                runerr(212, dx);
  94.  
  95. #ifdef StandardLib
  96.             if (status & Fs_Writing) {
  97.                fseek(fd, 0L, SEEK_CUR);
  98.                BlkLoc(dx)->file.status &= ~Fs_Writing;
  99.                }
  100.             BlkLoc(dx)->file.status |= Fs_Reading;
  101.             status = BlkLoc(dx)->file.status;
  102. #endif                    /* StandardLib */
  103.  
  104.             for (;;) {
  105.                StrLen(result) = 0;
  106.                do {
  107. #ifdef RecordIO
  108.                   if ((slen = (status & Fs_Record ?
  109.                                getrec(sbuf, MaxCvtLen, fd) :
  110.                                getstrg(sbuf, MaxCvtLen, fd))) == -1)
  111. #else                    /* RecordIO */
  112.                   if ((slen = getstrg(sbuf,MaxCvtLen,fd)) == -1)
  113. #endif                                  /* RecordIO */
  114.                      fail;
  115.                   rlen = slen < 0 ? (word)MaxCvtLen : slen;
  116.                   Protect(sp = alcstr(sbuf,rlen), runerr(0));
  117.                   if (StrLen(result) == 0)
  118.                      StrLoc(result) = sp;
  119.                   StrLen(result) += rlen;
  120.                   } while (slen < 0);
  121.                suspend result;
  122.                }
  123.             }
  124.          }
  125.  
  126.       table: {
  127.          abstract {
  128.             return type(dx).tbl_elem
  129.            }
  130.          inline {
  131.             /*
  132.              * x is a table.  Chain down the element list in each bucket
  133.              * and suspend a variable pointing to each element in turn.
  134.              */
  135.         for (ep = hgfirst(BlkLoc(dx), &state); ep != 0;
  136.            ep = hgnext(BlkLoc(dx), &state, ep))
  137.                   suspend struct_var(&ep->telem.tval, ep);
  138.             }
  139.          }
  140.  
  141.       set: {
  142.          abstract {
  143.             return store[type(dx).set_elem]
  144.             }
  145.          inline {
  146.             /*
  147.              *  This is similar to the method for tables except that a
  148.              *  value is returned instead of a variable.
  149.              */
  150.         for (ep = hgfirst(BlkLoc(dx), &state); ep != 0;
  151.            ep = hgnext(BlkLoc(dx), &state, ep))
  152.                   suspend ep->selem.setmem;
  153.         }
  154.          }
  155.  
  156.       record: {
  157.          abstract {
  158.             return type(dx).all_fields
  159.            }
  160.          inline {
  161.             /*
  162.              * x is a record.  Loop through the fields and suspend
  163.              * a variable pointing to each one.
  164.              */
  165.             j = BlkLoc(dx)->record.recdesc->proc.nfields;
  166.             for (i = 0; i < j; i++)
  167.                suspend struct_var(&BlkLoc(dx)->record.fields[i], 
  168.                   (struct b_record *)BlkLoc(dx));
  169.             }
  170.          }
  171.  
  172.       default: /* This object can not be compromised. */
  173.          runerr(116, dx);
  174.       }
  175.  
  176.    inline {
  177.       fail;
  178.       }
  179. end      
  180.  
  181. #define RandVal (RanScale*(k_random=(RandA*k_random+RandC)&MaxLong))
  182.  
  183. "?x - produce a randomly selected element of x."
  184.  
  185. operator{0,1} ? random(underef x -> dx)
  186.    declare {
  187.       C_integer v;
  188.       }
  189.  
  190.    if is:variable(x) && is:string(dx) then {
  191.       abstract {
  192.          return new tvsubs(type(x))
  193.          }
  194.       body {
  195.          C_integer val;
  196.          double rval;
  197.  
  198.          /*
  199.           * A string from a variable is being banged. Produce a one
  200.           *  character substring trapped variable.
  201.           */
  202.          if ((val = StrLen(dx)) <= 0)
  203.             fail;
  204.          rval = RandVal;    /* This form is used to get around */
  205.          rval *= val;        /* a bug in a certain C compiler */
  206.          return substr(&x, (word)rval + 1, (word)1);
  207.          }
  208.       }
  209.    else type_case dx of {
  210.       string: {
  211.          /*
  212.           * x is a string, but it is not a variable. Produce a
  213.           *   random character in it as the result; a substring
  214.           *   trapped variable is not needed.
  215.           */
  216.          abstract {
  217.             return string
  218.             }
  219.          body {
  220.             C_integer val;
  221.             double rval;
  222.  
  223.             if ((val = StrLen(dx)) <= 0)
  224.                fail;
  225.             rval = RandVal;
  226.             rval *= val;
  227.             return string(1, StrLoc(dx)+(word)rval);
  228.             }
  229.          }
  230.  
  231.       cset: {
  232.          /*
  233.           * x is a cset.  Convert it to a string, select a random character
  234.           *  of that string and return it. A substring trapped variable is
  235.           *  not needed.
  236.           */
  237.          if !cnv:tmp_string(dx) then
  238.             { /* cannot fail */ }
  239.          abstract {
  240.             return string
  241.             }
  242.          body {
  243.             C_integer val;
  244.             double rval;
  245.         char ch;
  246.  
  247.             if ((val = StrLen(dx)) <= 0)
  248.                fail;
  249.             rval = RandVal;
  250.             rval *= val;
  251.             ch = *(StrLoc(dx) + (word)rval);
  252.             return string(1, &allchars[FromAscii(ch) & 0xFF]);
  253.             }
  254.          }
  255.  
  256.       list: {
  257.          abstract {
  258.             return type(dx).lst_elem
  259.             }
  260.          /*
  261.           * x is a list.  Set i to a random number in the range [1,*x],
  262.           *  failing if the list is empty.
  263.           */
  264.          body {
  265.             C_integer val;
  266.             double rval;
  267.             register C_integer i, j;
  268.             union block *bp;     /* doesn't need to be tended */
  269.  
  270.             val = BlkLoc(dx)->list.size;
  271.             if (val <= 0)
  272.                fail;
  273.             rval = RandVal;
  274.             rval *= val;
  275.             i = (word)rval + 1;
  276.             j = 1;
  277.             /*
  278.              * Work down chain list of list blocks and find the block that
  279.              *  contains the selected element.
  280.              */
  281.             bp = BlkLoc(dx)->list.listhead;
  282.             while (i >= j + bp->lelem.nused) {
  283.                j += bp->lelem.nused;
  284.                bp = bp->lelem.listnext;
  285.                if (bp == NULL)
  286.                   syserr("list reference out of bounds in random");
  287.                }
  288.             /*
  289.              * Locate the appropriate element and return a variable
  290.              * that points to it.
  291.              */
  292.             i += bp->lelem.first - j;
  293.             if (i >= bp->lelem.nslots)
  294.                i -= bp->lelem.nslots;
  295.             return struct_var(&bp->lelem.lslots[i], bp);
  296.             }
  297.          }
  298.  
  299.       table: {
  300.          abstract {
  301.             return type(dx).tbl_elem
  302.             }
  303.           /*
  304.            * x is a table.  Set n to a random number in the range [1,*x],
  305.            *  failing if the table is empty.
  306.            */
  307.          body {
  308.             C_integer val;
  309.             double rval;
  310.             register C_integer i, j, n;
  311.             union block *ep, *bp;   /* doesn't need to be tended */
  312.         struct b_slots *seg;
  313.  
  314.             bp = BlkLoc(dx);
  315.             val = bp->table.size;
  316.             if (val <= 0)
  317.                fail;
  318.             rval = RandVal;
  319.             rval *= val;
  320.             n = (word)rval + 1;
  321.  
  322.             /*
  323.              * Walk down the hash chains to find and return the nth element
  324.          *  as a variable.
  325.              */
  326.             for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++)
  327.                for (j = segsize[i] - 1; j >= 0; j--)
  328.                   for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink)
  329.                      if (--n <= 0)
  330.                         return struct_var(&ep->telem.tval, ep);
  331.             }
  332.          }
  333.  
  334.       set: {
  335.          abstract {
  336.             return store[type(dx).set_elem]
  337.             }
  338.          /*
  339.           * x is a set.  Set n to a random number in the range [1,*x],
  340.           *  failing if the set is empty.
  341.           */
  342.          body {
  343.             C_integer val;
  344.             double rval;
  345.             register C_integer i, j, n;
  346.             union block *bp, *ep;  /* doesn't need to be tended */
  347.         struct b_slots *seg;
  348.  
  349.             bp = BlkLoc(dx);
  350.             val = bp->set.size;
  351.             if (val <= 0)
  352.                fail;
  353.             rval = RandVal;
  354.             rval *= val;
  355.             n = (word)rval + 1;
  356.             /*
  357.              * Walk down the hash chains to find and return the nth element.
  358.              */
  359.             for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++)
  360.                for (j = segsize[i] - 1; j >= 0; j--)
  361.                   for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink)
  362.                      if (--n <= 0)
  363.                         return ep->selem.setmem;
  364.             }
  365.          }
  366.  
  367.       record: {
  368.          abstract {
  369.             return type(dx).all_fields
  370.             }
  371.          /*
  372.           * x is a record.  Set val to a random number in the range
  373.           *  [1,*x] (*x is the number of fields), failing if the
  374.           *  record has no fields.
  375.           */
  376.          body {
  377.             C_integer val;
  378.             double rval;
  379.             struct b_record *rec;  /* doesn't need to be tended */
  380.  
  381.             rec = (struct b_record *)BlkLoc(dx);
  382.             val = rec->recdesc->proc.nfields;
  383.             if (val <= 0)
  384.                fail;
  385.             /*
  386.              * Locate the selected element and return a variable
  387.              * that points to it
  388.              */
  389.             rval = RandVal;
  390.             rval *= val;
  391.             return struct_var(&rec->fields[(word)rval], rec);
  392.             }
  393.          }
  394.  
  395.       default: {
  396.  
  397. #ifdef LargeInts
  398.          if !cnv:integer(dx) then
  399.             runerr(113, dx)
  400. #else                    /* LargeInts */
  401.          if !cnv:C_integer(dx,v) then
  402.             runerr(113, dx)
  403. #endif                    /* LargeInts */
  404.          abstract {
  405.             return integer ++ real
  406.             }
  407.          body {
  408.             double rval;
  409.  
  410. #ifdef LargeInts
  411.             if (Type(dx) == T_Lrgint) {
  412.            if (bigrand(&dx, &result) == Error)  /* alcbignum failed */
  413.               runerr(0);
  414.            return result;
  415.            }
  416.  
  417.             v = IntVal(dx);
  418. #endif                    /* LargeInts */
  419.             /*
  420.              * x is an integer, be sure that it's non-negative.
  421.              */
  422.             if (v < 0) 
  423.                runerr(205, dx);
  424.  
  425.             /*
  426.              * val contains the integer value of x. If val is 0, return
  427.              *    a real in the range [0,1), else return an integer in the
  428.              *    range [1,val].
  429.              */
  430.             if (v == 0) {
  431.                rval = RandVal;
  432.                return C_double rval;
  433.                }
  434.             else {
  435.                rval = RandVal;
  436.                rval *= v;
  437.                return C_integer (long)rval + 1;
  438.                }
  439.             }
  440.          }
  441.       }
  442. end
  443.  
  444.  
  445. "x[i:j] - form a substring or list section of x."
  446.  
  447. operator{0,1} [:] sect(underef x -> dx, i, j)
  448.    declare {
  449.       int use_trap = 0;
  450.       }
  451.  
  452.    if !cnv:C_integer(i) then
  453.       runerr(101, i)
  454.    if !cnv:C_integer(j) then
  455.       runerr(101, j)
  456.  
  457.    if is:list(dx) then {
  458.       abstract {
  459.          return type(dx)
  460.          }
  461.       body {
  462.          C_integer t;
  463.  
  464.          i = cvpos((long)i, (long)BlkLoc(dx)->list.size);
  465.          if (i == CvtFail)
  466.             fail;
  467.          j = cvpos((long)j, (long)BlkLoc(dx)->list.size);
  468.          if (j == CvtFail)
  469.             fail;
  470.          if (i > j) {
  471.             t = i;
  472.             i = j;
  473.             j = t;
  474.             }
  475.          if (cplist(&dx, &result, i, j) == Error)
  476.         runerr(0);
  477.          return result;
  478.          }
  479.       }
  480.    else {
  481.       /*
  482.        * x should be a string. If x is a variable, we must create a
  483.        *  substring trapped variable.
  484.        */
  485.       if is:variable(x) && is:string(dx) then {
  486.          abstract {
  487.             return new tvsubs(type(x))
  488.             }
  489.          inline {
  490.             use_trap = 1;
  491.             }
  492.          }
  493.       else if cnv:string(dx) then
  494.          abstract {
  495.             return string
  496.             }
  497.       else
  498.          runerr(110, dx)
  499.  
  500.       body {
  501.          C_integer t;
  502.  
  503.          i = cvpos((long)i, (long)StrLen(dx));
  504.          if (i == CvtFail)
  505.             fail;
  506.          j = cvpos((long)j, (long)StrLen(dx));
  507.          if (j == CvtFail)
  508.             fail;
  509.          if (i > j) {             /* convert section to substring */
  510.             t = i;
  511.             i = j;
  512.             j = t - j;
  513.             }
  514.          else
  515.             j = j - i;
  516.    
  517.          if (use_trap) {
  518.             return substr(&x, i, j);
  519.             }
  520.          else
  521.             return string(j, StrLoc(dx)+i-1);
  522.          }
  523.       }
  524. end
  525.  
  526.  
  527. "x[y] - access yth character or element of x."
  528.  
  529. operator{0,1} [] subsc(underef x -> dx,y)
  530.    declare {
  531.       int use_trap = 0;
  532.       char ch;
  533.       }
  534.  
  535.    type_case dx of {
  536.       list: {
  537.          abstract {
  538.             return type(dx).lst_elem
  539.             }
  540.          /*
  541.           * Make sure that y is an integer and that the
  542.           *  subscript is in range.
  543.           */
  544.          if !cnv:C_integer(y) then
  545.             runerr(101, y)
  546.          body {
  547.             word i, j;
  548.             register union block *bp; /* doesn't need to be tended */
  549.             struct b_list *lp;        /* doesn't need to be tended */
  550.  
  551.             lp = (struct b_list *)BlkLoc(dx);
  552.             i = cvpos((long)y, (long)lp->size);
  553.             if (i == CvtFail || i > lp->size)
  554.                fail;
  555.             /*
  556.              * Locate the list-element block containing the desired
  557.              *  element.
  558.              */
  559.             bp = lp->listhead;
  560.             j = 1;
  561.             while (bp != NULL && i >= j + bp->lelem.nused) {
  562.                j += bp->lelem.nused;
  563.                bp = bp->lelem.listnext;
  564.                }
  565.  
  566.             /*
  567.              * Locate the desired element and return a pointer to it.
  568.              */
  569.             i += bp->lelem.first - j;
  570.             if (i >= bp->lelem.nslots)
  571.                i -= bp->lelem.nslots;
  572.             return struct_var(&bp->lelem.lslots[i], bp);
  573.             }
  574.          }
  575.  
  576.       table: {
  577.          abstract {
  578.             store[type(dx).key] = type(y) /* the key might be added */
  579.             return type(dx).tbl_elem ++ new tvtbl(type(dx))
  580.             }
  581.          /*
  582.           * x is a table.  Locate the appropriate bucket
  583.           *  based on the hash value.
  584.           */
  585.          body {
  586.             uword hn;
  587.             int res;
  588.             register union block *bp; /* doesn't need to be tended */
  589.             union block **dp1;
  590.         struct b_tvtbl *tp;
  591.  
  592.             hn = hash(&y);
  593.             dp1 = memb(BlkLoc(dx), &y, hn, &res);
  594.             if (res == 1) {
  595.                bp = *dp1;
  596.                return struct_var(&bp->telem.tval, bp);
  597.             }
  598.             else {
  599.                /*
  600.                 * dx[y] is not in the table, make a table element trapped
  601.                 *  variable and return it as the result.
  602.                 */
  603.                Protect(tp = alctvtbl(&dx, &y, hn), runerr(0));
  604.                return tvtbl(tp);
  605.                }
  606.             }
  607.          }
  608.  
  609.       record: {
  610.          abstract {
  611.             return type(dx).all_fields
  612.             }
  613.          /*
  614.           * x is a record.  Convert y to an integer and be sure that it
  615.           *  it is in range as a field number.
  616.           */
  617.          if !cnv:C_integer(y) then
  618.             runerr(101, y)
  619.          body {
  620.             word i;
  621.             register union block *bp; /* doesn't need to be tended */
  622.  
  623.             bp = BlkLoc(dx);
  624.             i = cvpos(y, (word)(bp->record.recdesc->proc.nfields));
  625.             if (i == CvtFail || i > bp->record.recdesc->proc.nfields)
  626.                fail;
  627.             /*
  628.              * Locate the appropriate field and return a pointer to it.
  629.              */
  630.             return struct_var(&bp->record.fields[i-1], bp);
  631.             }
  632.          }
  633.  
  634.       default: {
  635.          /*
  636.           * dx must either be a string or be convertable to one. Decide
  637.           *  whether a substring trapped variable can be created.
  638.           */
  639.          if is:variable(x) && is:string(dx) then {
  640.             abstract {
  641.                return new tvsubs(type(x))
  642.                }
  643.             inline {
  644.                use_trap = 1;
  645.                }
  646.             }
  647.          else if cnv:tmp_string(dx) then
  648.             abstract {
  649.                return string
  650.                }
  651.          else
  652.             runerr(114, dx)
  653.  
  654.          /*
  655.           * Make sure that y is an integer.
  656.           */
  657.          if !cnv:C_integer(y) then
  658.             runerr(101, y)
  659.  
  660.          body {
  661.             word i;
  662.  
  663.             /*
  664.              * Convert y to a position in x and fail if the position
  665.              *  is out of bounds.
  666.              */
  667.             i = cvpos(y, StrLen(dx));
  668.             if (i == CvtFail || i > StrLen(dx))
  669.                fail;
  670.             if (use_trap) {
  671.                /*
  672.                 * x is a string, make a substring trapped variable for the
  673.                 * one character substring selected and return it.
  674.                 */
  675.                return substr(&x, i, (word)1);
  676.                }
  677.             else {
  678.                /*
  679.                 * x was converted to a string, so it cannot be assigned
  680.                 * back into. Just return a string containing the selected
  681.                 * character.
  682.                 */
  683.                ch = *(StrLoc(dx)+i-1);
  684.                return string(1, &allchars[FromAscii(ch) & 0xFF]);
  685.                }
  686.             }
  687.          }
  688.       }
  689. end
  690.